home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d19 / propck25.arc / SOURCE.ARC / PROPACK.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-29  |  33KB  |  1,313 lines
  1.  
  2. (*
  3.  * ProPack - Quickly Pack a PCBoard message base file
  4.  *
  5.  * Samuel H. Smith, 21-May-88 (rev. 01-05-89)
  6.  *
  7.  * Copyright 1988 Samuel H. Smith; All rights reserved.
  8.  *
  9.  * This program is provided courtesy of:
  10.  *         The Tool Shop
  11.  *         Phoenix, Az
  12.  *         (602) 279-2673
  13.  *
  14.  *)
  15.  
  16. {$I PRODEF.INC}
  17. {$M 8000,0,0}  {stack, minheap, maxheap}
  18.  
  19.  
  20. uses ErrTrap,Dos,MdosIO,BufIO,DosMem,CRC32;
  21.  
  22. const
  23.    bug = false;
  24.    crcfilever = -1;        {.crc file format version number}
  25.  
  26.    version:    string[10] = 'v2.5';
  27.    pcbver:     string[5] = '14.0';
  28.    revdate:    string[8] = '05-01-89';
  29.  
  30.    maxinbuf    = 160;      {input buffer records}
  31.    maxoutbuf   = 320;      {output buffer records}
  32.  
  33.    maxtxtblock = 80;       {message text buffer records}
  34.    blksiz      = 128;
  35.    maxlines    = 100;      {maximum number of text lines}
  36.    maxmsgs     = 15000;    {maximum number of active messages}
  37.  
  38.  
  39. {$i anystring.inc}
  40. {$i atoi.inc}        {ascii to integer conversion}
  41. {$i stof.dcl}
  42. {$i stof.inc}        {basic single to pascal float conversions}
  43. {$i keypress.inc}    {keypressed and readkey}
  44. {$i gettime.inc}     {lget_ms and others}
  45.  
  46.  
  47. (* layout of the message control file records for PCBoard *)
  48.  
  49. type
  50.  
  51.    message_rec = record
  52.       case integer of
  53.  
  54.       {file header record}
  55.          0: (himsg:    single;      {highest message on file}
  56.              lowmsg:   single;      {low msg number in message base}
  57.              msgcnt:   single;      {number of active messages}
  58.              callers:  single;      {number of callers on system}
  59.              lockflag: char6;       {LOCKED if file being updated}
  60.              fill1:    array[1..105] of char);
  61.                                     {reserved for future use}
  62.       {message header record}
  63.          1: (StatusCode:  char;     {protect, unprotect flag '*' or blank}
  64.              Number:      single;   {message number}
  65.              ReferTo:     single;   {reference message number}
  66.              blocks:      byte;     {number of blksiz byte text blocks}
  67.              Date:        char8;    {mm-dd-yy}
  68.              Time:        char5;    {hh:mm}
  69.              WhoTo:       char25;
  70.              ReadDate:    single;   {yymmdd numeric date of reply message}
  71.              ReadTime:    char5;    {hh:mm of reply}
  72.              HasReplys:   char;     {'R' is ALL message has replys}
  73.              WhoFrom:     char25;
  74.              Subject:     char25;
  75.              Password:    char12;   {blank=none}
  76.              status:      char;     {dead_msg(226) or live_msg(225)}
  77.              echoflag:    char;     {'E' if msg to be echoed}
  78.              filler:      char6);   {reserved}
  79.  
  80.       {message text record}
  81.          2: (body:      array[1..blksiz] of char);
  82.                                     {body of the message, space fill}
  83.    end;
  84.  
  85.  
  86. const
  87.    dead_msg    = #226;           {message status codes}
  88.    live_msg    = #225;
  89.    endline     = #227;           {end of line character in message files}
  90.    
  91.  
  92. type
  93.    ixarray  = array[1..maxmsgs+10] of single;   {index for each message}
  94.    crcarray = array[1..maxmsgs+10] of longint;  {crc of each message}
  95.    
  96. const
  97.    maxactive:  word     = 0;     {maximum number of messages to keep}
  98.    active:     word     = 0;     {active messages}
  99.    killed:     word     = 0;     {messages killed}
  100.    skipped:    word     = 0;     {messages skipped}
  101.    dups:       word     = 0;     {duplicate messages}
  102.    oldref:     word     = 0;     {obsolete refer#'s cleared}
  103.    received:   word     = 0;     {received+private messages skipped}
  104.    unrecvd:    word     = 0;     {unreceived+private messages kept}
  105.  
  106.    firstmsg:   longint  = 0;     {first message number to keep}
  107.    basemsg:    longint  = 0;     {base message number}
  108.    lastmsg:    longint  = 0;     {highest message number}
  109.    curnum:     longint  = 0;     {current message number}
  110.  
  111.    ixfd:       dos_handle = 0;   {index file handle}
  112.    ixsize:     longint  = 0;     {index file size in bytes}
  113.    ixcnt:      word     = 0;     {index entries allocated}
  114.    ixbuf:      ^ixarray = nil;   {pointer to index file buffer}
  115.    lastix:     word     = 0;     {highest index entry used}
  116.    
  117.    basecrc:    longint  = 0;     {base message number in crc table}
  118.    lastcrc:    word     = 0;     {highest crc table entry}
  119.    msgcrc:     ^crcarray = nil;  {pointer to message crc buffer}
  120.    
  121.    killdups:   boolean  = false; {kill duplicate messages?}
  122.    killrecvd:  boolean  = false; {kill RECEIVED+PRIVATE messages?}
  123.    keepunrecvd:boolean  = false; {keep UnRECEIVED+PRIVATE messages?}
  124.    listdups:   boolean  = false; {list duplicates as they are deleted}
  125.    sethimsg:   boolean  = false; {reset 'high message number'}
  126.    cleantags:  boolean  = false; {cleanup message taglines?}
  127.    novia:      boolean  = false; {remove Via and tearlines}
  128.    maxtags:    integer  = 9;     {maximum number of taglines}
  129.    nocrctags:  boolean  = false; {exclude taglines in crc calculation}
  130.    relay2:     boolean  = false; {keep 2 line Relay: taglines}
  131.    noibm:      boolean  = false; {remove IBM and high ascii codes}
  132.  
  133.    firstdate:  char6    = '000000';  {yymmdd oldest message date to keep}
  134.  
  135. var
  136.    infd:       buffered_file;    {input file handle}
  137.    outfd:      buffered_file;    {output file handle}
  138.    msgfile:    dos_filename;     {original message base filename}
  139.    newfile:    dos_filename;     {new message base filename}
  140.    bakfile:    dos_filename;     {backup filename}
  141.    ndxfile:    dos_filename;     {index filename}
  142.    crcfile:    dos_filename;     {crc filename}
  143.  
  144.    mheader:    message_rec;      {message base header record}
  145.  
  146.    header:     message_rec;      {current message header}
  147.    txtblocks:  integer;          {text blocks in current message}
  148.  
  149.    block:      array[1..maxtxtblock]
  150.                of message_rec;   {current text blocks}
  151.  
  152.    raw:        array[1..maxtxtblock*blksiz]
  153.                of char           {raw form of text blocks}
  154.                absolute block;
  155.  
  156.    maxpos:     integer;          {end of data in raw/block}
  157.  
  158.    lines:      array[1..maxlines+10]
  159.                of string80;      {line form of text blocks}
  160.  
  161.    linecnt:    integer;
  162.    vialine:    integer;
  163.    tearline:   integer;
  164.    tagline:    integer;
  165.  
  166.    con:        text;
  167.  
  168.    cmdline:    string[128];      {command line options used}
  169.  
  170.    t_start:    longint;
  171.  
  172.  
  173. procedure echo_message(what: string);
  174. begin
  175.    writeln;
  176.    write(what);   write(con,^M,what);
  177.    writeln;
  178. end;
  179.  
  180. procedure stop_run(why: string);
  181. begin
  182.    echo_message('!ABORT: '+why);
  183.    halt(1);
  184. end;
  185.  
  186.  
  187. (* --------------------------------------------------------- *)
  188. (*                 command line handlers                     *)
  189. (* --------------------------------------------------------- *)
  190.  
  191. procedure usage(why: string80);
  192.    {display program usage instructions}
  193. var
  194.    i: integer;
  195.    stop: longint;
  196.  
  197. begin
  198. {$i-}
  199.    writeln(con,'ProPack ',version,': Fast PCB ',pcbver,' Message Packer;  (C) 1988, 1989 Samuel H. Smith');
  200.    writeln(con,'Courtesy of The Tool Shop BBS, (602) 279-2673.'^M^J);
  201.    echo_message(why+'!');
  202.  
  203.    writeln(con,^M^J'Command options used: ');
  204.    write(con,'   PROPACK ');
  205.    for i := 1 to paramcount do
  206.       write(con,paramstr(i),' ');
  207.  
  208.    write(con,^M^J^M^J^M^J^G^G'Press ENTER (3 minute delay): ');
  209.    stop := lget_ms + 180000;  {3 minutes}
  210.    while (not keypressed) and (lget_ms < stop) do
  211.       ;
  212.    readln;
  213.  
  214.    writeln(con,^M^J'Usage:  ProPack MAILFILE MAXMSGS [/DHLRTUV] [/Nxxx]'^M^J);
  215.    writeln(con,'   MAILFILE  Mail file d:\path\name to be packed');
  216.    writeln(con,'   MAXMSGS   Maximum number of messages to keep, 0=no limit');
  217.    writeln(con,'   /D        Kill identical duplicate messages');
  218.    writeln(con,'   /E        Exclude taglines when checking for duplicates');
  219.    writeln(con,'   /H        Reset "high message number" to last message number');
  220.    writeln(con,'   /I        Remove IBM and "high ascii" codes');
  221.    writeln(con,'   /L        List duplicate message numbers as they are killed');
  222.    writeln(con,'   /Nxxx     Kill messages over xxx days old');
  223.    writeln(con,'   /R        Purge RECEIVED+PRIVATE messages');
  224.    writeln(con,'   /T        Remove extra network tag-lines');
  225.    writeln(con,'   /U        Always keep UN-RECEIVED+PRIVATE messages');
  226.    writeln(con,'   /V        Remove reader via-lines');
  227.    writeln(con,'   /W        Keep second line PCRelay: tagline'^M^J);
  228.    writeln(con,'Example:  ProPack d:\pcb\main\msgs 1000');
  229.    writeln(con,'          ProPack c:\pcb\tools\tools 500 /d /l');
  230.    writeln(con,'          ProPack c:\pcb\sysops\sysops 13000 /RDLT /N90');
  231. {$i+}
  232.    stop_run(why);
  233. end;
  234.  
  235.  
  236. (* --------------------------------------------------------- *)
  237. procedure itoa2(i: integer; var sp);
  238. var
  239.    s: array[1..2] of char absolute sp;
  240. begin
  241.    s[1] := chr( (i div 10) + ord('0'));
  242.    s[2] := chr( (i mod 10) + ord('0'));
  243. end;
  244.  
  245.  
  246. procedure determine_first_date(days: integer);
  247.    (* determine first_date as n days before today *)
  248. var
  249.    year:    word;
  250.    month:   word;
  251.    day:     word;
  252.    dow:     word;
  253.  
  254. const
  255.    monthdays:  array[1..12] of integer =
  256.       (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
  257.  
  258. begin
  259.    { get today's date from DOS }
  260.    GetDate(year,month,day,dow);
  261.    year := year - 1900;
  262.  
  263.    { backup N days }
  264.    while (days > 0) do
  265.    begin
  266.       dec(days);
  267.  
  268.       if (day > 1) then
  269.          dec(day)
  270.       else
  271.  
  272.       if (month > 1) then
  273.       begin
  274.          dec(month);
  275.          day := monthdays[month];
  276.       end
  277.       else
  278.  
  279.       begin
  280.          dec(year);
  281.          month := 12;
  282.          day := monthdays[month];
  283.       end;
  284.    end;
  285.  
  286.    { format the date for comparison }
  287.    itoa2(year,firstdate[1]);
  288.    itoa2(month,firstdate[3]);
  289.    itoa2(day,firstdate[5]);
  290.  
  291.    writeln('Skipping all messages before ',month,'-',day,'-',year);
  292. end;
  293.  
  294.  
  295. (* --------------------------------------------------------- *)
  296. procedure decode_params;
  297. var
  298.    i:    integer;
  299.    par:  string[128];
  300.  
  301. begin
  302.    writeln;
  303.  
  304.    t_start := lget_ms;
  305.    assign(con,'con');
  306.    rewrite(con);
  307.  
  308.    if paramcount < 2 then
  309.       usage('Missing command line parameters');
  310.  
  311.    msgfile := paramstr(1);
  312.    newfile := msgfile + '.NEW';
  313.    bakfile := msgfile + '.BAK';
  314.    ndxfile := msgfile + '.NDX';
  315.    crcfile := msgfile + '.CRC';
  316.  
  317.    par := paramstr(2);
  318.    for i := 1 to length(par) do
  319.       if (par[i] < '0') or (par[i] > '9') then
  320.          usage('Invalid digit in "MAXMSGS" parameter ('+par+')');
  321.  
  322.    maxactive := atow(paramstr(2));
  323.  
  324.    par := '';
  325.    for i := 3 to paramcount do
  326.       par := par + paramstr(i);
  327.  
  328.    fillchar(cmdline,sizeof(cmdline),0);
  329.    cmdline := par;
  330.  
  331.    i := 1;
  332.    while i <= length(par) do
  333.    begin
  334.  
  335.       case upcase(par[i]) of
  336.          '/':  ;
  337.  
  338.          'D':  killdups := true;
  339.  
  340.          'E':  begin
  341.                   killdups := true;
  342.                   nocrctags := true;
  343.                end;
  344.  
  345.          'H':  sethimsg := true;
  346.  
  347.          'I':  noibm := true;
  348.  
  349.          'L':  listdups := true;
  350.  
  351.          'N':  determine_first_date(atoi(copy(par,i+1,5)));
  352.  
  353.          'R':  killrecvd := true;
  354.  
  355.          'T':  begin
  356.                   cleantags := true;
  357.                   maxtags := 1;
  358.                end;
  359.  
  360.          'U':  keepunrecvd := true;
  361.  
  362.          'V':  begin
  363.                   cleantags := true;
  364.                   novia := true;
  365.                end;
  366.  
  367.          'W':  relay2 := true;
  368.  
  369.          '0'..'9':
  370.                ;
  371.  
  372. (*********
  373.          '0':  begin
  374.                   cleantags := true;
  375.                   maxtags := 0;
  376.                end;
  377. *********)
  378.  
  379.       else
  380.          usage('Unknown option: '+par);
  381.  
  382.       end;
  383.  
  384.       inc(i);
  385.    end;
  386.  
  387. end;
  388.  
  389.  
  390. (* --------------------------------------------------------- *)
  391. procedure rename_files;
  392. var
  393.    fd: file;
  394. begin
  395.    assign(fd,msgfile);
  396.    {$i-} rename(fd,bakfile); {$i+}
  397.    if ioresult <> 0 then
  398.    begin
  399. {$i-}
  400.       writeln(con,'Error: Could not rename old msgbase to .BAK!');
  401.       writeln(con,'Make sure that no other programs are accessing ',msgfile);
  402.       writeln(con,'Your message file is unchanged.');
  403. {$i+}
  404.       dos_unlink(newfile);    {release aborted scratch file}
  405.       stop_run('Could not rename '+msgfile+' to '+bakfile);
  406.    end;
  407.       
  408.    assign(fd,newfile);
  409.    {$i-} rename(fd,msgfile); {$i+}
  410.    if ioresult <> 0 then
  411.    begin
  412. {$i-}
  413.       writeln(con,'Error: Could not rename new msgbase!');
  414.       writeln(con,'Your message has been renamed to ',bakfile);
  415. {$i+}
  416.       dos_unlink(newfile);    {release aborted scratch file}
  417.       stop_run('Could not rename '+newfile+' to '+msgfile);
  418.    end;
  419. end;
  420.  
  421.  
  422. procedure iocheck;
  423.    {check for write failure}
  424. begin
  425.    if berr then
  426.    begin
  427. {$i-}
  428.       writeln(con,'Write failure!  You are probably out of disk space.');
  429.       writeln(con,'Your message file is unchanged.');
  430. {$i+}
  431.       bclose(outfd);
  432.       dos_unlink(newfile);    {release aborted scratch file}
  433.       stop_run('Write failure');
  434.    end;
  435. end;
  436.  
  437.  
  438. (* --------------------------------------------------------- *)
  439. (*             message tagline processing                    *)
  440. (* --------------------------------------------------------- *)
  441.  
  442. procedure delete_trailing_spaces(var line: string);
  443. begin
  444.    while (length(line) > 0) and (line[length(line)] = ' ') do
  445.       dec(line[0]);
  446. end;
  447.  
  448. procedure delete_line(n: integer);
  449. var
  450.    i: integer;
  451. begin
  452.    if n > linecnt then
  453.       exit;
  454.    for i := n to linecnt-1 do
  455.       lines[i] := lines[i+1];
  456.    dec(linecnt);
  457. end;
  458.  
  459. procedure insert_line(n: integer);
  460. var
  461.    i: integer;
  462. begin
  463.    if linecnt >= maxlines then
  464.       exit;
  465.    for i := linecnt downto n do
  466.       lines[i+1] := lines[i];
  467.    lines[n] := '';
  468.    inc(linecnt);
  469. end;
  470.  
  471.  
  472. procedure get_text;
  473.    {convert PCBoard's block format text into normal text lines}
  474. var
  475.    n:       integer;
  476. const
  477.    c:       char = '?';
  478.    tline:   string80 = '';
  479.    rawp:    integer = 0;
  480.  
  481. begin
  482.    {convert them into lines of text}
  483.    fillchar(lines,sizeof(lines),0);
  484.    linecnt := 0;
  485.    tline := '';
  486.    maxpos := txtblocks*blksiz;
  487.    rawp := 1;
  488.  
  489.    while rawp <= maxpos do
  490.    begin
  491.  
  492.       {grab next char from buffer}
  493.       c := raw[rawp];
  494.       inc(rawp);
  495.  
  496.       {end of line seen - store the line}
  497.       if (c = endline) or (c = ^J) then
  498.       begin
  499.          if linecnt >= maxlines then
  500.          begin
  501.             writeln('      ');
  502.             write('    Message # ',curnum,' has more than ',maxlines,' lines!  Truncated. ');
  503.             lines[maxlines] := '<<MESSAGE TOO LONG -- SOME LINES WERE DELETED>>';
  504.             exit;
  505.          end;
  506.  
  507.          delete_trailing_spaces(tline);
  508.          inc(linecnt);
  509.          lines[linecnt] := tline;
  510.          tline := '';
  511.       end
  512.       else
  513.  
  514.       {append the byte to the buffer (this hack goes faster than +c) }
  515.       if c <> ^M then
  516.       begin
  517.          if length(tline) < 80 then
  518.             inc(tline[0]);
  519.          tline[length(tline)] := c;
  520.       end;
  521.  
  522.    end;
  523. end;
  524.  
  525.  
  526. (* ---------------------------------------------------------- *)
  527. procedure put_msgtext(s: string80);
  528. begin
  529.    if maxpos+length(s) > sizeof(raw) then
  530.       exit;
  531.    move(s[1], raw[maxpos+1], length(s));
  532.    inc(maxpos,length(s));
  533. end;
  534.  
  535. procedure put_text;
  536.    {convert the text into PCBoard's block format and write it to the file}
  537. var
  538.    i:         integer;
  539. begin
  540.    {convert the lines into a block of bytes}
  541.    maxpos := 0;
  542.    for i := 1 to linecnt do
  543.    begin
  544.       put_msgtext(lines[i]);
  545.       put_msgtext(endline);
  546.    end;
  547.  
  548.    while (maxpos and 127) <> 0 do
  549.       put_msgtext(' ');
  550.  
  551.    txtblocks := maxpos div blksiz;
  552.    header.blocks := txtblocks+1;
  553. end;
  554.  
  555.  
  556. (* ---------------------------------------------------------- *)
  557. procedure analyze_taglines;
  558. var
  559.    i:          integer;
  560.  
  561. begin
  562.    {locate the tearline, if present}
  563.    tearline := 0;
  564.    i := linecnt;
  565.  
  566.    while (i > 0) and (tearline = 0) do
  567.       if (lines[i][1] <> ' ') and (lines[i] <> '') then
  568.          tearline := i
  569.       else
  570.          dec(i);
  571.  
  572.    {locate all taglines and vialines}
  573.    vialine := 0;
  574.    tagline := 0;
  575.  
  576.    for i := 1 to linecnt do
  577.    begin
  578.  
  579.       if lines[i][8] = ':' then
  580.       begin
  581.          if copy(lines[i],1,8) = 'PCRelay:' then
  582.          if tagline = 0 then
  583.             tagline := i;
  584.  
  585. if bug then begin
  586. writeln;
  587. write('relay at line ',i,' tagline=',tagline,' tear=',tearline,' via=',vialine);
  588. end;
  589.  
  590.       end
  591.       else
  592.  
  593.       if lines[i][4] = '/' then
  594.       begin
  595.          if copy(lines[i],1,8) = 'NET/Mail' then
  596.          if tagline = 0 then
  597.             tagline := i;
  598.       end
  599.       else
  600.  
  601.       if lines[i][4] = '' then
  602.       begin
  603.          if copy(lines[i],1,8) = 'NETMail' then
  604.          if tagline = 0 then
  605.             tagline := i;
  606.       end
  607.       else
  608.  
  609.       if lines[i][1] = ' ' then
  610.       begin
  611.          case lines[i][2] of
  612.          '*':
  613.             begin                      {qnet/qmail/prodoor}
  614.                 if lines[i-1] = '---' then
  615.                    vialine := i
  616.                 else
  617.                 if tagline = 0 then
  618.                    tagline := i;
  619.              end;
  620.  
  621.          '-':                          {relaymail/pcbrelay}
  622.              if lines[i][3] = '>' then
  623.              begin
  624.                 if copy(lines[i],1,9) = ' -> Relay' then
  625.                    vialine := i
  626.                 else
  627.                 if tagline = 0 then
  628.                    tagline := i;
  629.              end;
  630.  
  631.          '.','■':                      {ez-reader}
  632.              if lines[i][5] = 'Z' then
  633.                vialine := i;
  634.  
  635.          end;
  636.       end;
  637.    end;
  638.  
  639.  
  640.    if (vialine > 0) and (tearline > 0) then
  641.       tearline := vialine-1;
  642.  
  643. if bug then begin
  644.    writeln;
  645.    for i := 1 to linecnt do
  646.    begin
  647.       writeln;
  648.       if i = tearline     then write('tear')
  649.       else if i = vialine then write('via ')
  650.       else if i = tagline then write('tag ')
  651.       else write('    ');
  652.       write(i:2,' "',copy(lines[i],1,60),'"');
  653.    end;
  654. end;
  655.  
  656.    {ignore taglines that come before the tearline}
  657.    if tagline < tearline then
  658.       tagline := 0;
  659.  
  660. if bug then begin
  661. writeln;
  662. write('final tagline=',tagline);
  663. end;
  664.  
  665. end;
  666.  
  667.  
  668. (* ---------------------------------------------------------- *)
  669. procedure clean_taglines;
  670. var
  671.    i:          integer;
  672.  
  673. begin
  674.  
  675.    {remove vialines if needed}
  676.    if vialine > 0 then
  677.    begin
  678.       if novia then
  679.       begin
  680.          delete_line(vialine);
  681.          dec(tagline);
  682.  
  683.          if (lines[vialine-1] = '---') or (lines[vialine-1] = '') then
  684.          begin
  685.             delete_line(vialine-1);
  686.             dec(tagline);
  687.          end;
  688.  
  689.          vialine := 0;
  690.       end
  691.       else
  692.  
  693.       {remove blank line between vialine and first tagline}
  694.       if tagline > vialine then
  695.          tagline := vialine+1;
  696.  
  697.      {ignore taglines that come before the tearline}
  698.      if tagline < tearline then
  699.         tagline := 0;
  700.    end;
  701.  
  702.  
  703.    if tagline > 0 then
  704.    begin
  705.  
  706. if bug then begin
  707. writeln;
  708. write('final tagline=',tagline);
  709. end;
  710.  
  711.       {remove blank lines between taglines}
  712.       i := tagline;
  713.       while i <= linecnt do
  714.       begin
  715.          if lines[i] = '' then
  716.             delete_line(i)
  717.          else
  718.             inc(i);
  719.       end;
  720.  
  721.       {remove all but N taglines if needed}
  722.       i := tagline+maxtags;
  723.  
  724. (******
  725. if i > 100 then
  726. begin
  727.    writeln('curnum=',curnum,' i=',i,' linecnt=',linecnt,' tagline=',tagline,' maxtags=',maxtags);
  728. end;
  729.  
  730. writeln('i=',i,' tag=',tagline,' lines[i-1]=',lines[i-1]);
  731. *****)
  732.  
  733.       if relay2 and (copy(lines[i-1],1,8) = 'PCRelay:') then
  734.          inc(i);
  735.  
  736.       while i <= linecnt do
  737.          delete_line(i);
  738.  
  739.       {make sure there is 1 blank line before the tagline}
  740.       if (vialine = 0) and (maxtags > 0) and (lines[tagline-1] <> '') then
  741.          insert_line(tagline);
  742.    end;
  743.  
  744. (*********)
  745. if bug then begin
  746. writeln;
  747. write('==================================');
  748. end;
  749. (**********)
  750. end;
  751.  
  752.  
  753. (* --------------------------------------------------------- *)
  754. (*             header record handlers                        *)
  755. (* --------------------------------------------------------- *)
  756.  
  757. procedure load_header;
  758. begin
  759.    bread(infd,mheader);
  760.    bwrite(outfd,mheader);
  761.  
  762.    basemsg := stol(mheader.lowmsg);
  763.    lastmsg := stol(mheader.himsg);
  764. end;
  765.  
  766.  
  767. (* --------------------------------------------------------- *)
  768. procedure update_header;
  769.    {update the message-base header record to reflect the correct number
  770.     of active messages on file}
  771. begin
  772.    ltos(active,mheader.msgcnt);
  773.    ltos(basemsg,mheader.lowmsg);
  774.  
  775.    if sethimsg then
  776.       ltos(lastmsg,mheader.himsg);
  777.  
  778.    bseek(outfd,0);
  779.    bwrite(outfd,mheader);
  780.    bclose(outfd);
  781. end;
  782.  
  783.  
  784. (* --------------------------------------------------------- *)
  785. (*             index file handlers                           *)
  786. (* --------------------------------------------------------- *)
  787.  
  788. procedure load_index;
  789. var
  790.    n:       word;
  791.    zero:    single;
  792.    msgs:    word;
  793.       
  794. begin
  795.    ixfd := dos_open(ndxfile,open_update);
  796.    if ixfd = dos_error then
  797.       usage('Can''t open index file: '+ndxfile);
  798.  
  799.    dos_lseek(ixfd,0,seek_end);
  800.    ixsize := dos_tell;
  801.    if ixsize > (word(maxmsgs) * word(sizeof(single))) then
  802.    begin
  803. {$i-}
  804.       writeln(con,'Your index is too large for ProPack to handle!');
  805.       writeln(con,'Use PCBSETUP to reduce the number of index blocks to 14 or less.');
  806.       writeln(con,'Then run PCBPACK to build the new, smaller index.');
  807. {$i+}
  808.       stop_run('Index too large');
  809.    end;
  810.  
  811.    dos_getmem(ixbuf,ixsize);
  812.    ixcnt := ixsize div sizeof(single);
  813.  
  814.  
  815.    {scan original index to fine starting message number to keep}
  816.    dos_lseek(ixfd,0,seek_start);
  817.    n := dos_read(ixfd,ixbuf^,ixsize);
  818.  
  819.    msgs := 0;
  820.    n := ixcnt;
  821.    while (n > 0) and (firstmsg = 0) do
  822.    begin
  823.       if stol(ixbuf^[n]) >= 1 then
  824.       begin
  825.          inc(msgs);
  826.          if msgs = maxactive then          {calculate first msg num to keep}
  827.             firstmsg := n + basemsg - 1;
  828.       end;
  829.       dec(n);
  830.    end;
  831.    {writeln('msgs=',msgs,' basemsg=',basemsg,' firstmsg=',firstmsg);}
  832.  
  833.  
  834.    {clear all index entries}
  835.    zeros(zero);
  836.    for n := 1 to ixcnt do
  837.       ixbuf^[n] := zero;
  838. end;
  839.  
  840.  
  841. (* --------------------------------------------------------- *)
  842. procedure update_index;
  843. begin
  844.    dos_lseek(ixfd,0,seek_start);
  845.    dos_write(ixfd,ixbuf^,ixsize);
  846.    dos_close(ixfd);
  847. end;
  848.  
  849.  
  850. (* --------------------------------------------------------- *)
  851. procedure store_index;
  852. var
  853.    ix:   integer;
  854. begin
  855.    if active = 1 then
  856.    begin
  857.       basemsg := curnum;
  858.       lastix := 1;
  859.    end;
  860.  
  861.    ix := curnum - basemsg + 1;
  862.    if ix > lastix then
  863.       lastix := ix;
  864.  
  865.    if lastix >= ixcnt then
  866.    begin
  867.       writeln('curnum=',curnum,' lastix=',lastix,' ixcnt=',ixcnt);
  868.       stop_run('Index file overflow');
  869.    end;
  870.  
  871.    ltos(btell(outfd)+1,ixbuf^[ix]);
  872. end;
  873.  
  874.  
  875.  
  876. (* --------------------------------------------------------- *)
  877. (*                 CRC file handlers                         *)
  878. (* --------------------------------------------------------- *)
  879.  
  880. procedure load_crc;
  881. var
  882.    crcfd:   dos_handle;
  883.    n:       integer;
  884.    ver:     integer;
  885.    cmd:     string[128];
  886.    junk4:   longint;
  887.  
  888. begin
  889.    dos_getmem(msgcrc,sizeof(crcarray));
  890.    fillchar(msgcrc^,sizeof(crcarray),0);
  891.  
  892.    if not dos_exists(crcfile) then
  893.       exit;
  894.  
  895.    crcfd := dos_open(crcfile,open_read);
  896.    n := dos_read(crcfd,ver,sizeof(ver));
  897.    if ver = crcfilever then
  898.    begin
  899.       n := dos_read(crcfd,cmd,sizeof(cmd));
  900.       if cmd = cmdline then
  901.       begin
  902.          n := dos_read(crcfd,junk4,sizeof(junk4));
  903.          n := dos_read(crcfd,junk4,sizeof(junk4));
  904.          n := dos_read(crcfd,basecrc,sizeof(basecrc));
  905.          n := dos_read(crcfd,lastcrc,sizeof(lastcrc));
  906.          n := dos_read(crcfd,msgcrc^,lastcrc*sizeof(msgcrc^[1]));
  907.       end;
  908.    end;
  909.  
  910.    dos_close(crcfd);
  911. end;
  912.  
  913.  
  914. (* --------------------------------------------------------- *)
  915. procedure save_crc;
  916. var
  917.    crcfd:   dos_handle;
  918.    ver:     integer;
  919.    junk4:   longint;
  920.  
  921. begin
  922.    crcfd := dos_create(crcfile);
  923.    if crcfd = dos_error then
  924.       usage('Can''t create CRC file: '+crcfile);
  925.  
  926.    ver := crcfilever;
  927.    dos_write(crcfd,ver,sizeof(ver));
  928.    dos_write(crcfd,cmdline,sizeof(cmdline));
  929.  
  930.    junk4 := 0;
  931.    dos_write(crcfd,junk4,sizeof(junk4));
  932.    dos_write(crcfd,junk4,sizeof(junk4));
  933.  
  934.    dos_write(crcfd,basecrc,sizeof(basecrc));
  935.    dos_write(crcfd,lastcrc,sizeof(lastcrc));
  936.    dos_write(crcfd,msgcrc^,lastcrc*sizeof(msgcrc^[1]));
  937.  
  938.    dos_close(crcfd);
  939. end;
  940.  
  941.  
  942. (* --------------------------------------------------------- *)
  943. procedure lookup_crc;
  944. var
  945.    ix:   integer;
  946. begin
  947.    if basecrc = 0 then
  948.    begin
  949.       basecrc := curnum;
  950.       lastcrc := 1;
  951.    end;
  952.  
  953.    ix := curnum - basecrc + 1;
  954.  
  955. (***
  956.    writeln('lookup ',curnum,' ix=',ix,' crc=',msgcrc^[ix],' lastcrc=',lastcrc,' basecrc=',basecrc);
  957. ***)
  958.  
  959.    if (ix > lastcrc) or (ix < 1) then
  960.       crc_out := 0
  961.    else
  962.       crc_out := msgcrc^[ix];
  963. end;
  964.  
  965.  
  966. (* --------------------------------------------------------- *)
  967. function unique_crc: boolean;
  968. var
  969.    i:    integer;
  970.    ix:   integer;
  971.  
  972. begin
  973.    if basecrc = 0 then
  974.    begin
  975.       basecrc := curnum;
  976.       lastcrc := 1;
  977.    end;
  978.  
  979.    ix := curnum - basecrc + 1;
  980.  
  981. (***
  982. writeln;
  983. write('num: ',curnum:5,' crc=',crc_out:11,' ix=',ix:3);
  984. ***)
  985.  
  986.    for i := 1 to ix-1 do
  987.       if (msgcrc^[i] = crc_out) then
  988.       begin
  989.          unique_crc := false;
  990.  
  991.          if listdups then
  992.          begin
  993.             writeln('      ');
  994.             write('    Message # ',curnum,' deleted because it is the same as # ',i+basecrc-1,'  ');
  995. (***
  996. writeln;
  997. writeln('**   crc=',crc_out,' ix=',ix);
  998. ***)
  999.          end;
  1000.          exit;
  1001.       end;
  1002.  
  1003.    unique_crc := true;
  1004. end;
  1005.  
  1006.  
  1007. (* --------------------------------------------------------- *)
  1008. procedure store_crc;
  1009.    {enter into crc table}
  1010. var
  1011.    ix:   integer;
  1012. begin
  1013.    ix := curnum - basecrc + 1;
  1014.    if ix > lastcrc then
  1015.       lastcrc := ix;
  1016.  
  1017.    if ix >= maxmsgs then
  1018.    begin
  1019.       writeln('ix=',ix,' maxmsgs=',maxmsgs);
  1020.       stop_run('crc table overflow');
  1021.    end;
  1022.  
  1023.    msgcrc^[ix] := crc_out;
  1024. end;
  1025.  
  1026.  
  1027. (* --------------------------------------------------------- *)
  1028. (*             message date comparison                       *)
  1029. (* --------------------------------------------------------- *)
  1030.  
  1031.  
  1032. function message_outdated: boolean;
  1033. var
  1034.    match:   char6;
  1035. begin
  1036.    match[1] := header.date[7];  {yy}
  1037.    match[2] := header.date[8];
  1038.    match[3] := header.date[1];  {mm}
  1039.    match[4] := header.date[2];
  1040.    match[5] := header.date[4];  {dd}
  1041.    match[6] := header.date[5];
  1042.    message_outdated := match < firstdate;
  1043. end;
  1044.  
  1045.  
  1046. (* --------------------------------------------------------- *)
  1047. (*             the mainline code...pack messages             *)
  1048. (* --------------------------------------------------------- *)
  1049.  
  1050. procedure process_message;
  1051. var
  1052.    n:          integer;
  1053.    i:          integer;
  1054.    refnum:     longint;
  1055.  
  1056. begin
  1057.    {load the message}
  1058.    bread(infd,header);
  1059.  
  1060.    txtblocks := header.blocks-1;
  1061.    curnum := stol(header.number);
  1062.  
  1063.    if (curnum mod 10) = 0 then
  1064.       write(con,curnum:5,^H^H^H^H^H);
  1065.  
  1066.  
  1067.    {reject invalid looking messages}
  1068.    if (txtblocks < 1) or (txtblocks > maxtxtblock) or
  1069.       ((active > 0) and (curnum < basemsg)) or (curnum > 999999999) then
  1070.       exit;
  1071.  
  1072.  
  1073.    {load text blocks of message}
  1074.    for i := 1 to txtblocks do
  1075.       bread(infd,block[i]);
  1076.  
  1077.  
  1078.    {check for dead messages}
  1079.    if header.status = dead_msg then
  1080.    begin
  1081.       inc(killed);
  1082.       exit;
  1083.    end;
  1084.  
  1085.  
  1086.    {determine if message is to be kept}
  1087.    {check for outdated messages to be purged}
  1088.    if curnum < firstmsg then
  1089.    begin
  1090.       {keep unReceived+private if needed}
  1091.       if keepunrecvd and ((header.StatusCode = '*') or
  1092.                           (header.StatusCode = '~') or
  1093.                           (header.StatusCode = '#')) then
  1094.       begin
  1095.          inc(unrecvd);     {count the kept message}
  1096.          inc(firstmsg);    {and skip another to make up for it}
  1097.       end
  1098.       else
  1099.  
  1100.       {skip all other old messages}
  1101.       begin
  1102.          inc(skipped);
  1103.          exit;
  1104.       end;
  1105.    end;
  1106.  
  1107.  
  1108.    {check for received+private messages if needed}
  1109.    if killrecvd then
  1110.       if (header.StatusCode = '+') or
  1111.          (header.StatusCode = '`') or
  1112.          (header.StatusCode = '$') then
  1113.       begin
  1114.          inc(received);
  1115.          exit;
  1116.       end;
  1117.  
  1118.  
  1119.    {remove messages that are too old}
  1120.    if message_outdated then
  1121.    begin
  1122.       inc(skipped);
  1123.       exit;
  1124.    end;
  1125.  
  1126.  
  1127.    {remove ibm and high-ascii codes if needed}
  1128.    maxpos := txtblocks*blksiz;
  1129.    if noibm then
  1130.       for i := 1 to maxpos do
  1131.          case raw[i] of
  1132.             endline:
  1133.                ;
  1134.  
  1135.             #0..#6,
  1136.             #8,#11,#12,
  1137.             #14..#31,
  1138.             #127..#255:
  1139.                raw[i] := '.';
  1140.          end;
  1141.  
  1142.  
  1143.    {lookup prior crc value for this message, 0 if none}
  1144.    lookup_crc;
  1145.  
  1146.  
  1147.    {clean up taglines if needed}
  1148.    if (cleantags or nocrctags) and (crc_out = 0) then
  1149.    begin
  1150.       get_text;
  1151.       analyze_taglines;
  1152.  
  1153.       if cleantags then
  1154.       begin
  1155.          clean_taglines;
  1156.          put_text;
  1157.       end;
  1158.    end;
  1159.  
  1160.  
  1161.    {compute message CRC only if no crc is available for it}
  1162.    if crc_out = 0 then
  1163.    begin
  1164.       crc_out := crc_seed;
  1165.       crcstr(header.whofrom,crc_out,sizeof(header.whofrom));
  1166.       crcstr(header.subject,crc_out,sizeof(header.subject));
  1167.  
  1168.       {compute crc of text blocks}
  1169.       if not nocrctags then
  1170.          crcstr(block,crc_out,txtblocks*sizeof(block[1]))
  1171.       else
  1172.  
  1173.       {exclude taglines from crc calculation if needed}
  1174.       begin
  1175.          i := linecnt;
  1176.          if (vialine > 0) and (vialine <= i) then i := vialine-1;
  1177.          if (tagline > 0) and (tagline <= i) then i := tagline-1;
  1178.          while i > 0 do
  1179.          begin
  1180.             crcstr(lines[i],crc_out,length(lines[i])+1);
  1181.             dec(i);
  1182.          end;
  1183.       end;
  1184.    end;
  1185.  
  1186.  
  1187.    {check for duplicates if needed}
  1188.    if killdups then
  1189.    begin
  1190.       case header.StatusCode of
  1191.          '*','+','~','`','#','$':
  1192.             ;                 {exclude private codes}
  1193.  
  1194.       else                    {check this message for duplication}
  1195.          if not unique_crc then
  1196.          begin
  1197.             inc(dups);
  1198.             exit;
  1199.          end;
  1200.       end;
  1201.    end;
  1202.  
  1203.  
  1204.    {message is to be kept - enter it into the index and crc files}
  1205.    inc(active);
  1206.    store_index;
  1207.    store_crc;
  1208.    lastmsg := curnum;
  1209.  
  1210.  
  1211.    {remove obsolete refer numbers}
  1212.    refnum := stol(header.referto);
  1213.    if (refnum > 0) then
  1214.       if (refnum < basemsg) or (refnum > lastmsg) or
  1215.          (stol(ixbuf^[refnum-basemsg+1]) < 1) then
  1216.    begin
  1217.       inc(oldref);
  1218.       zeros(header.referto);
  1219.    end;
  1220.  
  1221.  
  1222.    {copy message to new message file}
  1223.    bwrite(outfd,header);
  1224.    iocheck;
  1225.    for i := 1 to txtblocks do
  1226.    begin
  1227.       bwrite(outfd,block[i]);
  1228.       iocheck;
  1229.    end;
  1230. end;
  1231.  
  1232.  
  1233. (* --------------------------------------------------------- *)
  1234. procedure scan_messages;
  1235.    {scan the message file and output header summaries}
  1236. begin
  1237.    dos_unlink(bakfile);    {make room}
  1238.  
  1239.    while not beof(infd) do
  1240.       process_message;
  1241.  
  1242.    bclose(infd);
  1243.    bflush(outfd);
  1244.    iocheck;
  1245. end;
  1246.  
  1247.  
  1248.  
  1249. (* --------------------------------------------------------- *)
  1250. procedure display_summary(var fd: text);
  1251. var
  1252.    elapsed: real;
  1253.  
  1254. begin
  1255.    if killdups then
  1256.       write(fd,dups:3,' dups, ');
  1257.  
  1258.    if killrecvd then
  1259.       write(fd,received:3,' received, ');
  1260.  
  1261.    elapsed := int(lget_ms - t_start) / 1000.0;
  1262.    write(fd,skipped:3,' skipped, ',
  1263.             killed:3,' dead, ',
  1264.             active:4,' active msgs, ',
  1265.             elapsed:5:1,' sec.');
  1266. end;
  1267.  
  1268.  
  1269. (* --------------------------------------------------------- *)
  1270. (*             the main program                              *)
  1271. (* --------------------------------------------------------- *)
  1272.  
  1273. var
  1274.    i: integer;
  1275. begin
  1276.    decode_params;
  1277.  
  1278.    bopen(infd,msgfile,maxinbuf,sizeof(message_rec));
  1279.    if berr then
  1280.       usage('Can''t open message file: '+msgfile);
  1281.  
  1282.    bcreate(newfile);
  1283.    bopen(outfd,newfile,maxoutbuf,sizeof(message_rec));
  1284.    
  1285.    write('Packing ',msgfile,' ...  Options: ',cmdline);
  1286.    write(con,^M,'':78,^M'Packing ',msgfile,' ...');
  1287.  
  1288.    load_header;
  1289.    load_index;
  1290.    load_crc;
  1291.  
  1292.    scan_messages;
  1293.  
  1294.    writeln(con,' Done!');
  1295.    writeln;
  1296.  
  1297.    update_header;
  1298.    rename_files;       
  1299.    update_index;
  1300.    save_crc;
  1301.  
  1302.    display_summary(output);
  1303.    write(con,^M);
  1304.    display_summary(con);
  1305.    writeln(con);
  1306.  
  1307.    dos_freemem(ixbuf);
  1308.    dos_freemem(msgcrc);
  1309.    halt(0);
  1310. end.
  1311.  
  1312.  
  1313.